home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / gnu / emacs / emacs1857 / bin_d2.zoo / lisp / ehelp.el < prev    next >
Lisp/Scheme  |  1991-12-02  |  12KB  |  339 lines
  1. ;; Copyright (C) 1986 Free Software Foundation, Inc.
  2.  
  3. ;; This file is part of GNU Emacs.
  4.  
  5. ;; GNU Emacs is free software; you can redistribute it and/or modify
  6. ;; it under the terms of the GNU General Public License as published by
  7. ;; the Free Software Foundation; either version 1, or (at your option)
  8. ;; any later version.
  9.  
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;; GNU General Public License for more details.
  14.  
  15. ;; You should have received a copy of the GNU General Public License
  16. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  17. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19. (require 'electric)
  20. (provide 'ehelp) 
  21.  
  22. (defvar electric-help-map ()
  23.   "Keymap defining commands available whilst scrolling
  24. through a buffer in electric-help-mode")
  25.  
  26. (put 'electric-help-undefined 'suppress-keymap t)
  27. (if electric-help-map
  28.     ()
  29.   (let ((map (make-keymap)))
  30.     (fillarray map 'electric-help-undefined)
  31.     (define-key map (char-to-string meta-prefix-char) (copy-keymap map))
  32.     (define-key map (char-to-string help-char) 'electric-help-help)
  33.     (define-key map "?" 'electric-help-help)
  34.     (define-key map " " 'scroll-up)
  35.     (define-key map "\^?" 'scroll-down)
  36.     (define-key map "." 'beginning-of-buffer)
  37.     (define-key map "<" 'beginning-of-buffer)
  38.     (define-key map ">" 'end-of-buffer)
  39.     ;(define-key map "\C-g" 'electric-help-exit)
  40.     (define-key map "q" 'electric-help-exit)
  41.     (define-key map "Q" 'electric-help-exit)
  42.     ;;a better key than this?
  43.     (define-key map "r" 'electric-help-retain)
  44.  
  45.     (setq electric-help-map map)))
  46.    
  47. (defun electric-help-mode ()
  48.   "with-electric-help temporarily places its buffer in this mode
  49. \(On exit from with-electric-help, the buffer is put in default-major-mode)"
  50.   (setq buffer-read-only t)
  51.   (setq mode-name "Help")
  52.   (setq major-mode 'help)
  53.   (setq mode-line-buffer-identification '(" Help:  %b"))
  54.   (use-local-map electric-help-map)
  55.   ;; this is done below in with-electric-help
  56.   ;(run-hooks 'electric-help-mode-hook)
  57.   )
  58.  
  59. (defun with-electric-help (thunk &optional buffer noerase)
  60.   "Arguments are THUNK &optional BUFFER NOERASE.
  61. BUFFER defaults to \"*Help*\"
  62. THUNK is a function of no arguments which is called to initialise
  63.  the contents of BUFFER.  BUFFER will be erased before THUNK is called unless
  64.  NOERASE is non-nil.  THUNK will be called with  standard-output  bound to
  65.  the buffer specified by BUFFER
  66.  
  67. After THUNK has been called, this function \"electrically\" pops up a window
  68. in which BUFFER is displayed and allows the user to scroll through that buffer
  69. in electric-help-mode.
  70. When the user exits (with electric-help-exit, or otherwise) the help
  71. buffer's window disappears (ie we use save-window-excursion)
  72. BUFFER is put into default-major-mode (or fundamental-mode) when we exit"
  73.   (setq buffer (get-buffer-create (or buffer "*Help*")))
  74.   (let ((one (one-window-p t))
  75.     (two nil))
  76.     (save-window-excursion
  77.       (save-excursion
  78.     (if one (goto-char (window-start (selected-window))))
  79.     (let ((pop-up-windows t))
  80.       (pop-to-buffer buffer))
  81.     (unwind-protect
  82.         (progn
  83.           (save-excursion
  84.         (set-buffer buffer)
  85.         (electric-help-mode)
  86.         (setq buffer-read-only nil)
  87.         (or noerase (erase-buffer)))
  88.           (let ((standard-output buffer))
  89.         (if (funcall thunk)
  90.             ()
  91.           (set-buffer buffer)
  92.           (set-buffer-modified-p nil)
  93.           (goto-char (point-min))
  94.           (if one (shrink-window-if-larger-than-buffer (selected-window)))))
  95.           (set-buffer buffer)
  96.           (run-hooks 'electric-help-mode-hook)
  97.           (setq two (electric-help-command-loop))
  98.           (cond ((eq (car-safe two) 'retain)
  99.              (setq two (vector (window-height (selected-window))
  100.                        (window-start (selected-window))
  101.                        (window-hscroll (selected-window))
  102.                        (point))))
  103.             (t (setq two nil))))
  104.                   
  105.       (message "")
  106.       (set-buffer buffer)
  107.       (setq buffer-read-only nil)
  108.       (condition-case ()
  109.           (funcall (or default-major-mode 'fundamental-mode))
  110.         (error nil)))))
  111.     (if two
  112.     (let ((pop-up-windows t)
  113.           tem)
  114.       (pop-to-buffer buffer)
  115.       (setq tem (- (window-height (selected-window)) (elt two 0)))
  116.       (if (> tem 0) (shrink-window tem))
  117.       (set-window-start (selected-window) (elt two 1) t)
  118.       (set-window-hscroll (selected-window) (elt two 2))
  119.       (goto-char (elt two 3)))
  120.       ;;>> Perhaps this shouldn't be done.
  121.       ;; so that when we say "Press space to bury" we mean it
  122.       (replace-buffer-in-windows buffer)
  123.       ;; must do this outside of save-window-excursion
  124.       (bury-buffer buffer))))
  125.  
  126. (defun electric-help-command-loop ()
  127.   (catch 'exit
  128.     (if (pos-visible-in-window-p (point-max))
  129.     (progn (message "<<< Press Space to bury the help buffer >>>")
  130.            (if (= (setq unread-command-char (read-char)) ?\  )
  131.            (progn (setq unread-command-char -1)
  132.               (throw 'exit t)))))
  133.     (let (up down both neither
  134.       (standard (and (eq (key-binding " ")
  135.                  'scroll-up)
  136.              (eq (key-binding "\^?")
  137.                  'scroll-down)
  138.              (eq (key-binding "Q")
  139.                  'electric-help-exit)
  140.              (eq (key-binding "q")
  141.                  'electric-help-exit))))
  142.       (Electric-command-loop
  143.         'exit
  144.     (function (lambda ()
  145.       (let ((min (pos-visible-in-window-p (point-min)))
  146.         (max (pos-visible-in-window-p (point-max))))
  147.         (cond ((and min max)
  148.            (cond (standard "Press Q to exit ")
  149.              (neither)
  150.              (t (setq neither (substitute-command-keys "Press \\[scroll-up] to exit ")))))
  151.           (min
  152.            (cond (standard "Press SPC to scroll, Q to exit ")
  153.              (up)
  154.              (t (setq up (substitute-command-keys "Press \\[scroll-up] to scroll; \\[electric-help-exit] to exit ")))))
  155.           (max
  156.            (cond (standard "Press DEL to scroll back, Q to exit ")
  157.              (down)
  158.              (t (setq down (substitute-command-keys "Press \\[scroll-down] to scroll back, \\[scroll-up] to exit ")))))
  159.           (t
  160.            (cond (standard "Press SPC to scroll, DEL to scroll back, Q to exit ")
  161.              (both)
  162.              (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit ")))))))))
  163.             t))))
  164.  
  165.  
  166.  
  167. ;(defun electric-help-scroll-up (arg)
  168. ;  ">>>Doc"
  169. ;  (interactive "P")
  170. ;  (if (and (null arg) (pos-visible-in-window-p (point-max)))
  171. ;      (electric-help-exit)
  172. ;    (scroll-up arg)))
  173.  
  174. (defun electric-help-exit ()
  175.   ">>>Doc"
  176.   (interactive)
  177.   (throw 'exit t))
  178.  
  179. (defun electric-help-retain ()
  180.   "Exit electric-help, retaining the current window/buffer conifiguration.
  181. \(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET
  182. will select it.)"
  183.   (interactive)
  184.   (throw 'exit '(retain)))
  185.  
  186.  
  187. ;(defun electric-help-undefined ()
  188. ;  (interactive)
  189. ;  (let* ((keys (this-command-keys))
  190. ;     (n (length keys)))
  191. ;    (if (or (= n 1)
  192. ;        (and (= n 2)
  193. ;         meta-flag
  194. ;         (eq (aref keys 0) meta-prefix-char)))
  195. ;    (setq unread-command-char last-input-char
  196. ;          current-prefix-arg prefix-arg)
  197. ;      ;;>>> I don't care.
  198. ;      ;;>>> The emacs command-loop is too much pure pain to
  199. ;      ;;>>> duplicate
  200. ;      ))
  201. ;  (throw 'exit t))
  202.  
  203. (defun electric-help-undefined ()
  204.   (interactive)
  205.   (error "%s is undefined -- Press %s to exit"
  206.      (mapconcat 'single-key-description (this-command-keys) " ")
  207.      (if (eq (key-binding "Q") 'electric-help-exit)
  208.          "Q"
  209.        (substitute-command-keys "\\[electric-help-exit]"))))
  210.  
  211.  
  212. ;>>> this needs to be hairified (recursive help, anybody?)
  213. (defun electric-help-help ()
  214.   (interactive)
  215.   (if (and (eq (key-binding "Q") 'electric-help-exit)
  216.        (eq (key-binding " ") 'scroll-up)
  217.        (eq (key-binding "\^?") 'scroll-down))
  218.       (message "SPC scrolls forward, DEL scrolls back, Q exits and burys help buffer")
  219.     ;; to give something for user to look at while slow substitute-cmd-keys
  220.     ;;  grinds away
  221.     (message "Help...")
  222.     (message "%s" (substitute-command-keys "\\[scroll-up] scrolls forward, \\[scroll-down] scrolls back, \\[electric-help-exit] exits.")))
  223.   (sit-for 2))
  224.  
  225.  
  226. (defun electric-helpify (fun)
  227.   (let ((name "*Help*"))
  228.     (if (save-window-excursion
  229.       ;; kludge-o-rama
  230.       (let* ((p (symbol-function 'print-help-return-message))
  231.          (b (get-buffe